home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / attributes.l next >
Lisp/Scheme  |  1988-09-12  |  24KB  |  660 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; Window Attributes
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;    The special variable *window-attributes* is an alist containg:
  22. ;;;    (drawable attributes attribute-changes geometry geometry-changes)
  23. ;;;    Where DRAWABLE is the associated window or pixmap
  24. ;;;          ATTRIBUTES is NIL or a reply-buffer containing the drawable's
  25. ;;;                 attributes for use by the accessors.
  26. ;;;          ATTRIBUTE-CHANGES is NIL or an array.  The first element
  27. ;;;             of the array is a "value-mask", indicating which
  28. ;;;             attributes have changed.  The other elements are
  29. ;;;             integers associated with the changed values, ready
  30. ;;;             for insertion into a server request.
  31. ;;;          GEOMETRY is like ATTRIBUTES, but for window geometry
  32. ;;;          GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
  33. ;;;
  34. ;;;    Attribute and Geometry accessors and SETF's look on the special variable
  35. ;;;    *window-attributes* for the drawable.  If its not there, the accessor is
  36. ;;;     NOT within a WITH-STATE, and a server request is made to get or put a value.
  37. ;;;     If an entry is found in *window-attributes*, the cache buffers are used
  38. ;;;    for the access.
  39. ;;;
  40. ;;;    All WITH-STATE has to do (re)bind *Window-attributes* to a list including
  41. ;;;    the new drawable.  The caches are initialized to NIL and allocated as needed.
  42.  
  43. (in-package 'xlib :use '(lisp))
  44.  
  45. (export '(
  46.       with-state
  47.       window-visual
  48.       window-class
  49.       window-background ;; setf only
  50.       window-border
  51.       window-bit-gravity
  52.       window-gravity
  53.       window-backing-store
  54.       window-backing-planes
  55.       window-backing-pixel
  56.       window-save-under
  57.       window-override-redirect
  58.       window-event-mask
  59.       window-do-not-propagate-mask
  60.       window-colormap
  61.       window-cursor
  62.       window-colormap-installed-p
  63.       window-all-event-masks
  64.       window-map-state
  65.       
  66.       drawable-root
  67.       drawable-x
  68.       drawable-y
  69.       drawable-width
  70.       drawable-height
  71.       drawable-depth
  72.       drawable-border-width
  73.  
  74.       window-priority
  75.       ))
  76.  
  77. (defconstant *attribute-size* 44)
  78. (defconstant *geometry-size* 24)
  79. (defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4)))
  80.  
  81. (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
  82.  
  83. ;; Window Attribute reply buffer resource
  84. (defvar *context-free-list* nil) ;; resource of free reply buffers
  85.  
  86. (defun allocate-context ()
  87.   (or (atomic-pop *context-free-list*)
  88.       (make-reply-buffer *context-size*)))
  89.  
  90. (defun deallocate-context (context)
  91.   (atomic-push context *context-free-list*))
  92.  
  93. (defmacro state-attributes (state) `(second ,state))
  94. (defmacro state-attribute-changes (state) `(third ,state))
  95. (defmacro state-geometry (state) `(fourth ,state))
  96. (defmacro state-geometry-changes (state) `(fifth ,state))
  97.  
  98. (defmacro drawable-equal-function ()
  99.   (if (member 'drawable *clx-cached-types*)
  100.       ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
  101.     ''drawable-equal))
  102.  
  103. (defmacro window-equal-function ()
  104.   (if (member 'window *clx-cached-types*)
  105.       ''eq
  106.     ''drawable-equal))
  107.  
  108. (defmacro with-state ((drawable) &body body)
  109.   ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
  110.   ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
  111.   ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
  112.   ;; indefinite scope of the body, on a per-process basis in a multi-process
  113.   ;; environment, the first call within an Accessor Group on the specified drawable
  114.   ;; (the object, not just the variable) causes the complete results of the protocol
  115.   ;; request to be retained, and returned in any subsequent accessor calls.  Calls
  116.   ;; within a Setf Group are delayed, and executed in a single request on exit from
  117.   ;; the body.  In addition, if a call on a function within an Accessor Group follows
  118.   ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
  119.   ;; that group are executed, any retained accessor information for that group is
  120.   ;; discarded, the corresponding protocol request is (re)issued, and the results are
  121.   ;; (again) retained, and returned in any subsequent accessor calls.
  122.  
  123.   ;; Accessor Group A (for GetWindowAttributes):
  124.   ;; window-visual, window-class, window-gravity, window-bit-gravity,
  125.   ;; window-backing-store, window-backing-planes, window-backing-pixel,
  126.   ;; window-save-under, window-colormap, window-colormap-installed-p,
  127.   ;; window-map-state, window-all-event-masks, window-event-mask,
  128.   ;; window-do-not-propagate-mask, window-override-redirect
  129.  
  130.   ;; Setf Group A (for ChangeWindowAttributes):
  131.   ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
  132.   ;; window-backing-pixel, window-save-under, window-event-mask,
  133.   ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
  134.   ;; window-cursor
  135.  
  136.   ;; Accessor Group G (for GetGeometry):
  137.   ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
  138.   ;; drawable-height, drawable-border-width
  139.  
  140.   ;; Setf Group G (for ConfigureWindow):
  141.   ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
  142.   ;; window-priority
  143.   (let ((state-entry (gensym)))
  144.      ;; alist of (drawable attributes attribute-changes geometry geometry-changes)
  145.     `(with-stack-list (,state-entry ,drawable nil nil nil nil)
  146.        (with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
  147.      (multiple-value-prog1
  148.        (progn ,@body)
  149.        (cleanup-state-entry ,state-entry))))))
  150.  
  151. (defun cleanup-state-entry (state)
  152.   ;; Return buffers to the free-list
  153.   (let ((entry (state-attributes state)))
  154.     (when entry (deallocate-context entry)))
  155.   (let ((entry (state-attribute-changes state)))
  156.     (when entry
  157.       (put-window-attribute-changes (car state) entry)
  158.       (deallocate-gcontext-state entry)))
  159.   (let ((entry (state-geometry state)))
  160.     (when entry (deallocate-context entry)))
  161.   (let ((entry (state-geometry-changes state)))
  162.     (when entry
  163.       (put-drawable-geometry-changes (car state) entry)
  164.       (deallocate-gcontext-state entry))))
  165.  
  166.  
  167.  
  168. (defun change-window-attribute (window number value)
  169.   ;; Called from window attribute SETF's to alter an attribute value
  170.   ;; number is the change-attributes request mask bit number
  171.   (declare (type window window)
  172.        (type card8 number)
  173.        (type card32 value))
  174.   (let ((state-entry nil)
  175.     (changes nil))
  176.     (if (and *window-attributes*
  177.          (setq state-entry (assoc window (the list *window-attributes*)
  178.                       :test (window-equal-function))))
  179.     (progn                    ; Within a WITH-STATE - cache changes
  180.       (setq changes (state-attribute-changes state-entry))
  181.       (unless changes
  182.         (setq changes (allocate-gcontext-state))
  183.         (setf (state-attribute-changes state-entry) changes)
  184.         (setf (aref changes 0) 0)) ;; Initialize mask to zero
  185.       (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
  186.       (setf (aref changes (1+ number)) value))    ;; save value
  187.                         ; Send change to the server
  188.       (with-buffer-request ((window-display window) *x-changewindowattributes*)
  189.     (window window)
  190.     (card32 (ash 1 number) value)))))
  191. ;;
  192. ;; These two are twins (change-window-attribute change-drawable-geometry)
  193. ;; If you change one, you probably need to change the other...
  194. ;;
  195. (defun change-drawable-geometry (drawable number value)
  196.   ;; Called from drawable geometry SETF's to alter an attribute value
  197.   ;; number is the change-attributes request mask bit number
  198.   (declare (type drawable drawable)
  199.        (type card8 number)
  200.        (type card29 value))
  201.   (let ((state-entry nil)
  202.     (changes nil))
  203.     (if (and *window-attributes*
  204.          (setq state-entry (assoc drawable (the list *window-attributes*)
  205.                       :test (drawable-equal-function))))
  206.     (progn                    ; Within a WITH-STATE - cache changes
  207.       (setq changes (state-geometry-changes state-entry))
  208.       (unless changes
  209.         (setq changes (allocate-gcontext-state))
  210.         (setf (state-geometry-changes state-entry) changes)
  211.         (setf (aref changes 0) 0)) ;; Initialize mask to zero
  212.       (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
  213.       (setf (aref changes (1+ number)) value))    ;; save value
  214.                         ; Send change to the server
  215.       (with-buffer-request ((drawable-display drawable) *x-configurewindow*)
  216.     (drawable drawable)
  217.     (card16 (ash 1 number))
  218.     (card29 value)))))
  219.  
  220. (defun get-window-attributes-buffer (window)
  221.   (declare (type window window))
  222.   (let ((state-entry nil)
  223.     (changes nil))
  224.     (or (and *window-attributes*
  225.          (setq state-entry (assoc window (the list *window-attributes*)
  226.                       :test (window-equal-function)))
  227.          (null (setq changes (state-attribute-changes state-entry)))
  228.          (state-attributes state-entry))
  229.     (let ((display (window-display window)))
  230.       (with-display (display)
  231.         ;; When SETF's have been done, flush changes to the server
  232.         (when changes
  233.           (put-window-attribute-changes window changes)
  234.           (deallocate-gcontext-state (state-attribute-changes state-entry))
  235.           (setf (state-attribute-changes state-entry) nil))
  236.         ;; Get window attributes
  237.         (with-buffer-request (display *x-getwindowattributes* :no-after)
  238.           (window window))
  239.         (let ((buffer (or (state-attributes state-entry)
  240.                   (allocate-context))))
  241.           (wait-for-reply display *attribute-size*)
  242.           ;; Copy into event from reply buffer
  243.           (buffer-replace (reply-ibuf8 buffer)
  244.                   (reply-ibuf8 (buffer-reply-buffer display))
  245.                   0
  246.                   *attribute-size*)
  247.           (when state-entry
  248.         (setf (state-attributes state-entry) buffer))
  249.           (display-invoke-after-function display)
  250.           buffer))))))
  251. ;;
  252. ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
  253. ;; If you change one, you probably need to change the other...
  254. ;;
  255. (defun get-drawable-geometry-buffer (drawable)
  256.   (declare (type drawable drawable))
  257.   (let ((state-entry nil)
  258.     (changes nil))
  259.     (or (and *window-attributes*
  260.          (setq state-entry (assoc drawable (the list *window-attributes*)
  261.                       :test (drawable-equal-function)))
  262.          (null (setq changes (state-geometry-changes state-entry)))
  263.          (state-geometry state-entry))
  264.     (let ((display (drawable-display drawable)))
  265.       (with-display (display)
  266.         ;; When SETF's have been done, flush changes to the server
  267.         (when changes
  268.           (put-drawable-geometry-changes drawable changes)
  269.           (deallocate-gcontext-state (state-geometry-changes state-entry))
  270.           (setf (state-geometry-changes state-entry) nil))
  271.         ;; Get drawable attributes
  272.         (with-buffer-request (display *x-getgeometry* :no-after)
  273.           (drawable drawable))
  274.         (let ((buffer (or (state-geometry state-entry)
  275.                   (allocate-context))))
  276.           (wait-for-reply display *geometry-size*)
  277.           ;; Copy into event from reply buffer
  278.           (buffer-replace (reply-ibuf8 buffer)
  279.                   (reply-ibuf8 (buffer-reply-buffer display))
  280.                   0
  281.                   *geometry-size*)
  282.           (when state-entry
  283.         (setf (state-geometry state-entry) buffer))
  284.           (display-invoke-after-function display)
  285.           buffer))))))
  286.  
  287. (defun put-window-attribute-changes (window changes)
  288.   ;; change window attributes
  289.   ;; Always from Called within a WITH-DISPLAY
  290.   (declare (type window window)
  291.        (type gcontext-state changes))
  292.   (let* ((display (window-display window))
  293.      (mask (aref changes 0)))
  294.     (declare (type display display)
  295.          (type mask32 mask))
  296.     (with-buffer-request (display *x-changewindowattributes*)
  297.       (window window)
  298.       (card32 mask)
  299.       (progn ;; Insert a word in the request for each one bit in the mask
  300.     (do ((bits mask (ash bits -1))
  301.          (request-size 2)            ;Word count
  302.          (i 1 (index+ i 1)))        ;Entry count
  303.         ((zerop bits)
  304.          (card16-put 2 (index-incf request-size))
  305.          (index-incf (buffer-boffset display) (index* request-size 4)))
  306.       (declare (type mask32 bits)
  307.            (type array-index i request-size))
  308.       (when (oddp bits)
  309.         (card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
  310. ;;
  311. ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
  312. ;; If you change one, you probably need to change the other...
  313. ;;
  314. (defun put-drawable-geometry-changes (window changes)
  315.   ;; change window attributes or geometry (depending on request-number...)
  316.   ;; Always from Called within a WITH-DISPLAY
  317.   (declare (type window window)
  318.        (type gcontext-state changes))
  319.   (let* ((display (window-display window))
  320.      (mask (aref changes 0)))
  321.     (declare (type display display)
  322.          (type mask16 mask))
  323.     (with-buffer-request (display *x-configurewindow*)
  324.       (window window)
  325.       (card16 mask)
  326.       (progn ;; Insert a word in the request for each one bit in the mask
  327.     (do ((bits mask (ash bits -1))
  328.          (request-size 2)            ;Word count
  329.          (i 1 (index+ i 1)))        ;Entry count
  330.         ((zerop bits)
  331.          (card16-put 2 (incf request-size))
  332.          (index-incf (buffer-boffset display) (* request-size 4)))
  333.       (declare (type mask16 bits)
  334.            (type fixnum request-size)
  335.            (type array-index i))
  336.       (when (oddp bits)
  337.         (card29-put (* (incf request-size) 4) (aref changes i))))))))
  338.  
  339. (defmacro with-attributes ((window &rest options) &body body)
  340.   (let ((buffer (gensym)))
  341.     `(let ((,buffer (get-window-attributes-buffer ,window)))
  342.        (prog1 
  343.      (with-buffer-input (,buffer ,@options) ,@body)
  344.      (unless *window-attributes*
  345.        (deallocate-context ,buffer))))))
  346. ;;
  347. ;; These two are twins (with-attributes with-geometry)
  348. ;; If you change one, you probably need to change the other...
  349. ;;
  350. (defmacro with-geometry ((window &rest options) &body body)
  351.   (let ((buffer (gensym)))
  352.     `(let ((,buffer (get-drawable-geometry-buffer ,window)))
  353.        (prog1 
  354.      (with-buffer-input (,buffer ,@options) ,@body)
  355.      (unless *window-attributes*
  356.        (deallocate-context ,buffer))))))
  357.  
  358. ;;;-----------------------------------------------------------------------------
  359. ;;; Group A: (for GetWindowAttributes)
  360. ;;;-----------------------------------------------------------------------------
  361.  
  362. (defun window-visual (window)
  363.   (declare (type window window))
  364.   (declare-values card29)
  365.   (with-attributes (window :sizes 32)
  366.     (resource-id-get 8)))
  367.  
  368. (defun window-class (window)
  369.   (declare (type window window))
  370.   (declare-values (member :input-output :input-only))
  371.   (with-attributes (window :sizes 16)
  372.     (member16-get 12 :copy :input-output :input-only)))
  373.  
  374. (defun set-window-background (window background)
  375.   (declare (type window window)
  376.        (type (or (member :none :parent-relative) pixel pixmap) background))
  377.   (cond ((eq background :none) (change-window-attribute window 0 0))
  378.     ((eq background :parent-relative) (change-window-attribute window 0 1))
  379.     ((integerp background) ;; Background pixel
  380.      (change-window-attribute window 0 0) ;; pixmap :NONE
  381.      (change-window-attribute window 1 background))
  382.     ((type? background 'pixmap) ;; Background pixmap
  383.      (change-window-attribute window 0 (pixmap-id background)))
  384.     (t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
  385.   background)
  386.  
  387. (defsetf window-background set-window-background)
  388.  
  389. (defun set-window-border (window border)
  390.   (declare (type window window)
  391.        (type (or (member :copy) pixel pixmap) border))
  392.   (cond ((eq border :copy) (change-window-attribute window 2 1))
  393.     ((type? border 'pixmap) ;; Border pixmap
  394.      (change-window-attribute window 2 (pixmap-id border)))
  395.     ((integerp border) ;; Border pixel
  396.      (change-window-attribute window 3 border))
  397.     (t (x-type-error border '(or (member :copy) integer pixmap))))
  398.   border)
  399.  
  400. (defsetf window-border set-window-border)
  401.  
  402. (defun window-bit-gravity (window)
  403.   ;; setf'able
  404.   (declare (type window window))
  405.   (declare-values bit-gravity)
  406.   (with-attributes (window :sizes 8)
  407.     (member8-vector-get 14 *bit-gravity-vector*)))
  408.  
  409. (defun set-window-bit-gravity (window gravity)
  410.   (change-window-attribute
  411.     window 4 (encode-type (member-vector *bit-gravity-vector*) gravity))
  412.   gravity)
  413.  
  414. (defsetf window-bit-gravity set-window-bit-gravity)
  415.  
  416. (defun window-gravity (window)
  417.   ;; setf'able
  418.   (declare (type window window))
  419.   (declare-values win-gravity)
  420.   (with-attributes (window :sizes 8)
  421.     (member8-vector-get 15 *win-gravity-vector*)))
  422.  
  423. (defun set-window-gravity (window gravity)
  424.   (change-window-attribute
  425.     window 5 (encode-type (member-vector *win-gravity-vector*) gravity))
  426.   gravity)
  427.  
  428. (defsetf window-gravity set-window-gravity)
  429.  
  430. (defun window-backing-store (window)
  431.   ;; setf'able
  432.   (declare (type window window))
  433.   (declare-values (member :not-useful :when-mapped :always))
  434.   (with-attributes (window :sizes 8)
  435.     (member8-get 1 :not-useful :when-mapped :always)))
  436.  
  437. (defun set-window-backing-store (window when)
  438.   (change-window-attribute
  439.     window 6 (encode-type (member :not-useful :when-mapped :always) when))
  440.   when)
  441.  
  442. (defsetf window-backing-store set-window-backing-store)
  443.  
  444. (defun window-backing-planes (window)
  445.   ;; setf'able
  446.   (declare (type window window))
  447.   (declare-values pixel)
  448.   (with-attributes (window :sizes 32)
  449.     (card32-get 16)))
  450.  
  451. (defun set-window-backing-planes (window planes)
  452.   (change-window-attribute window 7 (encode-type card32 planes))
  453.   planes)
  454.  
  455. (defsetf window-backing-planes set-window-backing-planes)
  456.  
  457. (defun window-backing-pixel (window)
  458.   ;; setf'able
  459.   (declare (type window window))
  460.   (declare-values pixel)
  461.   (with-attributes (window :sizes 32)
  462.     (card32-get 20)))
  463.  
  464. (defun set-window-backing-pixel (window pixel)
  465.   (change-window-attribute window 8 (encode-type card32 pixel))
  466.   pixel)
  467.  
  468. (defsetf window-backing-pixel set-window-backing-pixel)
  469.  
  470. (defun window-save-under (window)
  471.   ;; setf'able
  472.   (declare (type window window))
  473.   (declare-values (member :off :on))
  474.   (with-attributes (window :sizes 8)
  475.     (member8-get 24 :off :on)))
  476.  
  477. (defun set-window-save-under (window when)
  478.   (change-window-attribute window 10 (encode-type (member :off :on) when))
  479.   when)
  480.  
  481. (defsetf window-save-under set-window-save-under)
  482.  
  483. (defun window-override-redirect (window)
  484.   ;; setf'able
  485.   (declare (type window window))
  486.   (declare-values (member :off :on))
  487.   (with-attributes (window :sizes 8)
  488.     (member8-get 27 :off :on)))
  489.  
  490. (defun set-window-override-redirect (window when)
  491.   (change-window-attribute window 9 (encode-type (member :off :on) when))
  492.   when)
  493.  
  494. (defsetf window-override-redirect set-window-override-redirect)
  495.  
  496. (defun window-event-mask (window)
  497.   ;; setf'able
  498.   (declare (type window window))
  499.   (declare-values mask32)
  500.   (with-attributes (window :sizes 32)
  501.     (card32-get 36)))
  502.  
  503. (defsetf window-event-mask (window) (event-mask)
  504.   (let ((em (gensym)))
  505.     `(let ((,em ,event-mask))
  506.        (change-window-attribute ,window 11 (encode-event-mask ,em))
  507.        ,em)))
  508.  
  509. (defun window-do-not-propagate-mask (window)
  510.   ;; setf'able
  511.   (declare (type window window))
  512.   (declare-values mask32)
  513.   (with-attributes (window :sizes 32)
  514.     (card32-get 40)))
  515.  
  516. (defsetf window-do-not-propagate-mask (window) (device-event-mask)
  517.   (let ((em (gensym)))
  518.     `(let ((,em ,device-event-mask))
  519.        (change-window-attribute ,window 12 (encode-device-event-mask ,em))
  520.        ,em)))
  521.  
  522. (defun window-colormap (window)
  523.   (declare (type window window))
  524.   (declare-values (or null colormap))
  525.   (with-attributes (window :sizes 32)
  526.     (let ((id (resource-id-get 28)))
  527.       (if (zerop id) nil
  528.     (lookup-colormap (window-display window) id)))))
  529.  
  530. (defun set-window-colormap (window colormap)
  531.   (change-window-attribute
  532.     window 13 (encode-type (or (member :copy) colormap) colormap))
  533.   colormap)
  534.  
  535. (defsetf window-colormap set-window-colormap)
  536.  
  537. (defun set-window-cursor (window cursor)
  538.   (change-window-attribute
  539.     window 14 (encode-type (or (member :none) cursor) cursor))
  540.   cursor)
  541.  
  542. (defsetf window-cursor set-window-cursor)
  543.  
  544. (defun window-colormap-installed-p (window)
  545.   (declare (type window window))
  546.   (declare-values boolean)
  547.   (with-attributes (window :sizes 8)
  548.     (boolean-get 25)))
  549.  
  550. (defun window-all-event-masks (window)
  551.   (declare (type window window))
  552.   (declare-values mask32)
  553.   (with-attributes (window :sizes 32)
  554.     (card32-get 32)))
  555.  
  556. (defun window-map-state (window)
  557.   (declare (type window window))
  558.   (declare-values (member :unmapped :unviewable :viewable))
  559.   (with-attributes (window :sizes 8)
  560.     (member8-get 26 :unmapped :unviewable :viewable)))
  561.  
  562.  
  563. ;;;-----------------------------------------------------------------------------
  564. ;;; Group G: (for GetGeometry)
  565. ;;;-----------------------------------------------------------------------------
  566.  
  567. (defun drawable-root (drawable)
  568.   (declare (type drawable drawable))
  569.   (declare-values window)
  570.   (with-geometry (drawable :sizes 32)
  571.     (window-get 8 (drawable-display drawable))))
  572.  
  573. (defun drawable-x (drawable)
  574.   ;; setf'able
  575.   (declare (type drawable drawable))
  576.   (declare-values int16)
  577.   (with-geometry (drawable :sizes 16)
  578.     (int16-get 12)))
  579.  
  580. (defun set-drawable-x (drawable x)
  581.   (change-drawable-geometry drawable 0 (encode-type int16 x))
  582.   x)
  583.  
  584. (defsetf drawable-x set-drawable-x)
  585.  
  586. (defun drawable-y (drawable)
  587.   ;; setf'able
  588.   (declare (type drawable drawable))
  589.   (declare-values int16)
  590.   (with-geometry (drawable :sizes 16)
  591.     (int16-get 14)))
  592.  
  593. (defun set-drawable-y (drawable y)
  594.   (change-drawable-geometry drawable 1 (encode-type int16 y))
  595.   y)
  596.  
  597. (defsetf drawable-y set-drawable-y)
  598.  
  599. (defun drawable-width (drawable)
  600.   ;; setf'able
  601.   ;; Inside width, excluding border.
  602.   (declare (type drawable drawable))
  603.   (declare-values card16)
  604.   (with-geometry (drawable :sizes 16)
  605.     (card16-get 16)))
  606.  
  607. (defun set-drawable-width (drawable width)
  608.   (change-drawable-geometry drawable 2 (encode-type card16 width))
  609.   width)
  610.  
  611. (defsetf drawable-width set-drawable-width)
  612.  
  613. (defun drawable-height (drawable)
  614.   ;; setf'able
  615.   ;; Inside height, excluding border.
  616.   (declare (type drawable drawable))
  617.   (declare-values card16)
  618.   (with-geometry (drawable :sizes 16)
  619.     (card16-get 18)))
  620.  
  621. (defun set-drawable-height (drawable height)
  622.   (change-drawable-geometry drawable 3 (encode-type card16 height))
  623.   height)
  624.  
  625. (defsetf drawable-height set-drawable-height)
  626.  
  627. (defun drawable-depth (drawable)
  628.   (declare (type drawable drawable))
  629.   (declare-values card8)
  630.   (with-geometry (drawable :sizes 8)
  631.     (card8-get 1)))
  632.  
  633. (defun drawable-border-width (drawable)
  634.   ;; setf'able
  635.   (declare (type drawable drawable))
  636.   (declare-values integer)
  637.   (with-geometry (drawable :sizes 16)
  638.     (card16-get 20)))
  639.  
  640. (defun set-drawable-border-width (drawable width)
  641.   (change-drawable-geometry drawable 4 (encode-type card16 width))
  642.   width)
  643.  
  644. (defsetf drawable-border-width set-drawable-border-width)
  645.  
  646. (defun set-window-priority (mode window sibling)
  647.   (declare (type (member :above :below :top-if :bottom-if :opposite) mode)
  648.        (type window window)
  649.        (type (or null window) sibling))
  650.   (with-state (window)
  651.     (change-drawable-geometry
  652.       window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
  653.     (when sibling
  654.       (change-drawable-geometry window 5 (encode-type window sibling))))
  655.   mode)
  656.  
  657. (defsetf window-priority (window &optional sibling) (mode)
  658.   ;; A bit strange, but retains setf form.
  659.   `(set-window-priority ,mode ,window ,sibling))
  660.